home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Aminet 1 (Walnut Creek)
/
Aminet - June 1993 [Walnut Creek].iso
/
aminet
/
dev
/
lang
/
pcq12src.lzh
/
Source
/
Expr.p
< prev
next >
Wrap
Text File
|
1991-04-18
|
28KB
|
1,005 lines
External;
{$I "Pascal.i"}
Function TypeCheck(l, r : TypePtr) : Boolean;
External;
Function TypeCmp(l, r : TypePtr) : Boolean;
External;
Procedure ReadChar;
External;
Procedure NextSymbol;
External;
Procedure Error(s : string);
External;
Procedure Abort;
External;
Function Match(s : Symbols): Boolean;
External;
Function FindID(s : string) : IDPtr;
External;
Function FindField(s : string; TP : TypePtr): IDPtr;
External;
Function FindWithField(S : String) : IDPtr;
External;
Procedure Mismatch;
External;
Procedure NeedRightParent;
External;
Procedure NeedLeftParent;
External;
Procedure NeedNumber;
External;
Function NumberType(l : TypePtr) : Boolean;
External;
Function BaseType(b : TypePtr): TypePtr;
External;
Function SimpleType(t : TypePtr) : Boolean;
External;
Function EnterStandard( st_Name : String;
st_Object : IDObject;
st_Type : TypePtr;
st_Storage : IDStorage;
st_Offset : Integer) : IDPtr;
External;
Function GetExpressionNode : ExprPtr;
var
Expr : ExprPtr;
begin
if NextFreeExprNode <= MaxExprNodes then begin
Expr := Adr(ExpressionNodeStore[NextFreeExprNode]);
Inc(NextFreeExprNode);
GetExpressionNode := Expr;
end else begin
New(Expr);
GetExpressionNode := Expr;
end;
end;
Procedure FreeExpressionNode(Expr : ExprPtr);
begin
Expr^.Used := False;
end;
Function MakeNode(Op : Symbols; L, R : ExprPtr; TP : TypePtr; Val : Integer) : ExprPtr;
var
Expr : ExprPtr;
begin
Expr := GetExpressionNode;
with Expr^ do begin
Kind := Op;
Next := Nil;
Left := L;
Right := R;
EType := BaseType(TP);
Value := Val;
end;
MakeNode := Expr;
end;
Function MakeBinary(Op : Symbols; L, R : ExprPtr; TP : TypePtr) : ExprPtr;
begin
MakeBinary := MakeNode(Op,L,R,TP,0);
end;
Function MakeCommutativeBinary(Op : Symbols; L, R : ExprPtr; TP : TypePtr) : ExprPtr;
begin
if L^.Kind = Const1 then
MakeCommutativeBinary := MakeNode(Op, L, R, TP, 0);
if R^.Kind = Const1 then
MakeCommutativeBinary := MakeNode(Op, R, L, TP, 0);
if (L^.Kind = Var1) or (L^.Kind = Period1) then
MakeCommutativeBinary := MakeNode(Op, L, R, TP, 0);
MakeCommutativeBinary := MakeNode(Op, R, L, TP, 0);
end;
Function MakeConstant(Val : Integer; TP : TypePtr) : ExprPtr;
begin
if (TP = StringType) or (TP^.Object = ob_array) then
MakeConstant := MakeNode(Quote1, Nil, Nil, TP, Val)
else
MakeConstant := MakeNode(Const1, Nil, Nil, TP, Val);
end;
Function MakeVariable(ID : IDPtr; TP : TypePtr) : ExprPtr;
begin
MakeVariable := MakeNode(Var1, Nil, Nil, TP, Integer(ID));
end;
Function CommonType(type1, type2 : TypePtr) : TypePtr;
begin
Type1 := BaseType(Type1);
Type2 := BaseType(Type2);
if (Type1 = BadType) or (Type2 = BadType) then
CommonType := BadType;
if (Type1 = RealType) or (Type2 = RealType) then
CommonType := RealType;
if (Type1 = IntType) or (Type2 = IntType) then
CommonType := IntType;
if (Type1 = ShortType) or (Type2 = ShortType) then
CommonType := ShortType;
if (Type1 = ByteType) or (Type2 = ByteType) then
CommonType := ByteType;
CommonType := Type1; { What else is there? }
end;
Function PromoteTypeA(Expr : ExprPtr; TP : TypePtr) : ExprPtr;
var
Common : TypePtr;
begin
Common := CommonType(Expr^.EType, TP);
if (Common = Expr^.EType) or (Common = BadType) then
PromoteTypeA := Expr;
if Common = RealType then
PromoteTypeA := MakeBinary(int2real, PromoteTypeA(Expr, IntType),
Nil, RealType)
else if Common = IntType then
PromoteTypeA := MakeBinary(short2long, PromoteTypeA(Expr, ShortType),
Nil, IntType)
else if Common = ShortType then
PromoteTypeA := MakeBinary(byte2short, Expr, Nil, ShortType)
else
PromoteTypeA := Expr;
end;
Procedure CheckNumeric(Expr : ExprPtr);
begin
if not NumberType(Expr^.EType) then begin
NeedNumber;
Expr^.EType := BadType;
end;
end;
Procedure CheckType(Left, Right : ExprPtr);
begin
if not TypeCheck(Left^.EType, Right^.EType) then begin
MisMatch;
Left^.EType := BadType;
Right^.EType := BadType;
end;
end;
Procedure CheckOrdinal(Expr : ExprPtr);
begin
if Expr^.EType^.Object <> ob_ordinal then begin
Expr^.EType := BadType;
Error("Expecting an Ordinal Expression");
end;
end;
Function AutoInt(Expr : ExprPtr) : ExprPtr;
begin
with Expr^ do begin
if EType = RealType then
AutoInt := MakeNode(real2int,Expr,Nil,IntType,0)
else
AutoInt := Expr;
end;
end;
Function ExpressionTree : ExprPtr;
Forward;
Function Factor : ExprPtr;
Forward;
Function GetReference : ExprPtr;
Forward;
Function BuildError(ErrorMsg : String) : ExprPtr;
begin
Error(ErrorMsg);
BuildError := MakeNode(unknown1, Nil, Nil, BadType, 0);
end;
Function OrdinalError : ExprPtr;
begin
OrdinalError := BuildError("Expecting an ordinal expression");
end;
Function NumericError : ExprPtr;
begin
NumericError := BuildError("Expecting a numeric expression");
end;
Procedure IncLitPtrA;
begin
if LitPtr >= LiteralSize then begin
Writeln('Too much literal data');
Abort;
end else
Inc(LitPtr);
end;
Function ReadLitA(Quote : Char) : TypePtr;
{
This routine reads a literal array of char into the literal
array.
}
var
Length : Short;
begin
Length := 1;
while (currentchar <> Quote) and (currentchar <> chr(10)) do begin
if CurrentChar = '\\' then begin
ReadChar;
if CurrentChar = Chr(10) then
Error("Missing closing quote");
case CurrentChar of
'n' : Litq[LitPtr] := Chr(10);
't' : Litq[LitPtr] := Chr(9);
'0' : Litq[LitPtr] := Chr(0);
'b' : Litq[LitPtr] := Chr(8);
'e' : Litq[LitPtr] := Chr(27);
'c' : Litq[LitPtr] := Chr($9B);
'a' : Litq[LitPtr] := Chr(7);
'f' : Litq[LitPtr] := Chr(12);
'r' : Litq[LitPtr] := Chr(13);
'v' : Litq[LitPtr] := Chr(11);
else
Litq[LitPtr] := CurrentChar;
end;
end else
Litq[LitPtr] := CurrentChar;
if CurrentChar <> Chr(10) then begin
ReadChar;
if currentchar = chr(10) then
error("Missing closing quote");
end;
Inc(Length);
IncLitPtrA;
end;
ReadChar;
NextSymbol;
if Quote = '"' then begin
LitQ[LitPtr] := Chr(0);
IncLitPtrA;
ReadLitA := StringType;
end else begin
LiteralType^.Upper := Length - 1;
ReadLitA := LiteralType;
end;
end;
Function GetStandardFunction(ID : IDPtr) : ExprPtr;
var
Expr : ExprPtr;
Expr2 : ExprPtr;
TypeID : IDPtr;
begin
NeedLeftParent;
if (ID^.Offset < 15) or (ID^.Offset > 16) then
Expr := ExpressionTree;
case ID^.Offset of
{Ord} 1 : begin
if Expr^.EType^.Object = ob_ordinal then begin
case Expr^.EType^.Size of
1 : Expr := MakeNode(stanfunc1, Expr, Nil, ByteType, 1);
2 : Expr := MakeNode(stanfunc1, Expr, Nil, ShortType, 1);
4 : Expr := MakeNode(stanfunc1, Expr, Nil, IntType, 1);
end;
end else
Expr := OrdinalError;
end;
{Chr} 2 : if NumberType(Expr^.EType) then
Expr := MakeNode(stanfunc1, AutoInt(Expr), Nil, CharType, 2)
else
Expr := NumericError;
{Odd} 3 : if NumberType(Expr^.EType) then
Expr := MakeNode(stanfunc1, AutoInt(Expr), Nil, BoolType, 3)
else
Expr := NumericError;
{Abs} 4 : if NumberType(Expr^.EType) then
Expr := MakeNode(stanfunc1, Expr, Nil, Expr^.EType, ID^.Offset)
else
Expr := NumericError;
{Succ} 5,
{Pred} 6 : if Expr^.Etype^.Object = ob_ordinal then
Expr := MakeNode(stanfunc1, Expr, Nil, Expr^.EType, ID^.Offset)
else
Expr := OrdinalError;
{ReOpen} 7,
{Open} 8 :
begin
if TypeCheck(StringType,Expr^.EType) then begin
if not Match(comma1) then
Error("Expecting a comma");
Expr2 := GetReference;
if Expr2^.EType^.Object = ob_file then
Expr := MakeNode(stanfunc1, Expr2, Expr, BoolType, ID^.Offset)
else
Expr := BuildError("Expecting a file type");
if Match(Comma1) then begin
Expr2 := ExpressionTree;
if not TypeCheck(Expr2^.EType,IntType) then
Expr2 := BuildError("Mismatched Types");
end else
Expr2 := MakeNode(Const1,Nil,Nil,IntType,128);
Expr^.Left^.Next := Expr2;
end else
Expr := BuildError("Expecting a string expression");
end;
{EOF} 9 : if Expr^.EType^.Object = ob_file then
Expr := MakeNode(stanfunc1, Expr, Nil, BoolType, 9)
else
Expr := BuildError("Expecting a file variable");
{Trunc} 10,
{Round} 11 :
if TypeCmp(Expr^.EType,RealType) then
Expr := MakeNode(stanfunc1, Expr, Nil, IntType, ID^.Offset)
else
Expr := BuildError("Expecting a floating point expression");
{Float} 12 : if NumberType(Expr^.EType) and (Expr^.EType^.Object = ob_ordinal) then
Expr := MakeNode(stanfunc1, PromoteTypeA(Expr,IntType),
Nil, RealType, 12)
else
Expr := BuildError("Expecting an ordinal number");
{Floor} 13,
{Ceil} 14 : if TypeCmp(Expr^.EType, RealType) then
Expr := MakeNode(stanfunc1, Expr, Nil, RealType, ID^.Offset)
else
Expr := BuildError("Expecting a floating point expression");
{SizeOf}
15 : begin
if CurrSym = Ident1 then begin
TypeID := FindId(SymText);
if TypeID <> Nil then begin
if TypeID^.Object = obtype then
Expr := MakeNode(Const1, Nil, Nil, IntType, TypeID^.VType^.Size)
else
Expr := BuildError("Expecting a type");
end else
Expr := BuildError("Unknown ID");
end else
Expr := BuildError("Expecting an ID");
NextSymbol;
end;
{Adr}
16 : Expr := MakeNode(at1, GetReference, Nil, AddressType, 0);
{Bit}
17 : if NumberType(Expr^.EType) and (Expr^.EType^.Object = ob_ordinal) then
Expr := MakeNode(shl1, MakeConstant(1,IntType), Expr, IntType, 17)
else
Expr := BuildError("Expecting an ordinal number");
{Sqr}18 : if NumberType(Expr^.EType) then
Expr := MakeNode(stanfunc1, Expr, Nil, Expr^.EType, 18)
else
Expr := NumericError;
19..25 : { Sin, Cos, Sqrt, Tan, ArcTan, Ln, Exp }
if NumberType(Expr^.EType) then
Expr := MakeNode(stanfunc1, PromoteTypeA(Expr,RealType),
Nil, RealType, ID^.Offset)
else
Expr := NumericError;
end;
NeedRightParent;
GetStandardFunction := Expr;
end;
Function ReadParameters(ID : IDPtr) : ExprPtr;
var
CurrentParam : IDPtr;
stay : Boolean;
argtype : TypePtr;
argindex : integer;
totalsize : integer;
lab : integer;
Expr : ExprPtr;
Argument : ExprPtr;
NextExpr : ExprPtr;
begin
Stay := True;
Expr := MakeNode(func1, Nil, Nil, ID^.VType, Integer(ID));
NextExpr := Nil;
if Match(LeftParent1) then begin
CurrentParam := ID^.Param;
while (not Match(RightParent1)) and Stay do begin
if CurrentParam = Nil then
ReadParameters := BuildError("Argument not expected");
if CurrentParam^.Object = valarg then begin
Argument := ExpressionTree;
if not TypeCheck(Argument^.EType, CurrentParam^.VType) then begin
Mismatch;
Argument := MakeConstant(1,BadType);
end else begin
if NumberType(Argument^.EType) then begin
if (Argument^.EType = RealType) and
(CurrentParam^.VType^.Object = ob_ordinal) then
Argument := MakeNode(Real2Int,
PromoteTypeA(Argument, IntType),
Nil,
CurrentParam^.VType,0)
else
Argument := PromoteTypeA(Argument, CurrentParam^.VType);
end;
end;
end else if CurrentParam^.Object = refarg then begin
Argument := GetReference;
if not TypeCmp(Argument^.EType, CurrentParam^.VType) then
Mismatch;
end;
if NextExpr = Nil then
Expr^.Left := Argument
else
NextExpr^.Next := Argument;
NextExpr := Argument;
CurrentParam := CurrentParam^.Next;
if CurrentParam <> Nil then
if not Match(Comma1) then
Error("Expected ,");
end;
if CurrentParam <> Nil then
error("More Parameters Expected");
end else begin
if ID^.Param <> Nil then
error("Expecting Some Parameters");
end;
ReadParameters := Expr;
end;
{
This function reads an identifier and makes an appropriate
node. The identifier can be a variable, function, constant,
or standard function.
}
Function ReadIdentifier : ExprPtr;
var
Expr : ExprPtr;
NextExpr : ExprPtr;
ID : IDPtr;
begin
ID := FindWithField(SymText);
if ID = Nil then
ID := FindID(SymText);
NextSymbol;
if ID = Nil then begin
ID := EnterStandard(SymText, global, BadType, st_none, 1);
{ ReadBadArgs(ID); }
ReadIdentifier := BuildError("Unknown ID");
end;
case ID^.Object of
obtype : begin
NeedLeftParent;
Expr := MakeBinary(Type1, ExpressionTree, Nil, ID^.VType);
NeedRightParent;
end;
constant : Expr := MakeConstant(ID^.Offset, ID^.VType);
global,
local,
refarg,
valarg : Expr := MakeNode(Var1, Nil, Nil, ID^.VType, Integer(ID));
typed_const : if ConstantExpression then
Expr := MakeConstant(ID^.Offset, ID^.VType)
else
Expr := MakeNode(Var1, Nil, Nil, ID^.VType, Integer(ID));
func : Expr := ReadParameters(ID);
stanfunc : Expr := GetStandardFunction(ID);
field : Expr := MakeNode(Field1,ExprPtr(LastWith),Nil,ID^.VType,Integer(ID));
else
Expr := BuildError("Expecting a variable or function reference");
end;
ReadIdentifier := Expr;
end;
Function Primary : ExprPtr;
var
Expr : ExprPtr;
TP,TP2 : TypePtr;
LitSpot : Integer;
begin
case CurrSym of
numeral1 : begin
if Abs(SymLoc) > 32767 then
Expr := MakeConstant(SymLoc, IntType)
else if (SymLoc > 255) or (SymLoc < 0) then
Expr := MakeConstant(SymLoc, ShortType)
else
Expr := MakeConstant(SymLoc, ByteType);
NextSymbol;
end;
realnumeral1:
begin
Expr := MakeConstant(Integer(RealValue), RealType);
NextSymbol;
end;
minus1 : begin
NextSymbol;
Expr := Factor;
if not NumberType(Expr^.EType) then
Expr := BuildError("Expecting a numeric type")
else
Expr := MakeNode(minus1, Expr, Nil, Expr^.EType, 0);
end;
plus1 : begin
NextSymbol;
Expr := Factor;
if not NumberType(Expr^.EType) then
Expr := BuildError("Expecting a numeric type");
end;
at1 : begin
NextSymbol;
Expr := MakeNode(at1, GetReference, Nil, AddressType, 0);
end;
not1 : begin
NextSymbol;
Expr := Factor;
if Expr^.EType^.Object <> ob_ordinal then
Expr := BuildError("Expecting an ordinal type")
else
Expr := MakeNode(not1, Expr, Nil, Expr^.EType, 0);
end;
ident1 : Expr := ReadIdentifier;
leftparent1 :
begin
NextSymbol;
Expr := ExpressionTree;
NeedRightParent;
end;
Apostrophe1 :
begin
LitSpot := LitPtr;
TP := ReadLitA(Chr(39));
if TP^.Upper = 1 then begin
Dec(LitPtr);
Expr := MakeConstant(Ord(LitQ[LitPtr]), CharType);
end else begin
New(TP2); { Add new type for array }
TP2^ := TP^;
TP2^.Next := CurrentBlock^.FirstType;
CurrentBlock^.FirstType := TP2;
Expr := MakeNode(quote1, Nil, Nil, TP2, LitSpot);
end;
end;
Quote1 : begin
LitSpot := LitPtr;
TP := ReadLitA('"');
Expr := MakeNode(quote1, Nil, Nil, TP, LitSpot);
end;
else
Expr := BuildError("Unknown Factor");
end;
Primary := Expr;
end;
Function MakeFieldRef(Expr : ExprPtr; Offset : Integer; TP : TypePtr) : ExprPtr;
begin
if Expr^.Kind = period1 then begin
Expr^.Value := Expr^.Value + Offset;
Expr^.EType := TP;
MakeFieldRef := Expr;
end;
MakeFieldRef := MakeNode(Period1, Expr, Nil, TP, Offset);
end;
Function MakeIndirection(Expr : ExprPtr) : ExprPtr;
var
Result : ExprPtr;
begin
MakeIndirection := MakeNode(Carat1, Expr, Nil, Expr^.EType^.SubType, 0);
end;
Function MakeIndex(L, R : ExprPtr; TP : TypePtr) : ExprPtr;
var
Result : ExprPtr;
begin
{
These first statements create the following structure:
*
/ \
element -
size / \
promote\
/ lower bound
index
expression
Which is the general calculation for array addressing:
base address + (index - lower bound) * element size
L := The expression for the array address
R := The expression for the index
}
case R^.EType^.Size of
1 : R^.EType := ByteType;
2 : R^.EType := ShortType;
4 : R^.EType := IntType;
end;
with L^.EType^ do begin
if Lower <> 0 then
R := MakeBinary(minus1,MakeConstant(Lower,R^.EType),
R, R^.EType);
if (Upper > MaxShort) or (SubType^.Size > MaxShort) then begin
R := MakeBinary(asterisk1,
MakeConstant(SubType^.Size,IntType),
PromoteTypeA(R,IntType),
IntType)
end else begin
R := MakeBinary(asterisk1,
MakeConstant(SubType^.Size,ShortType),
PromoteTypeA(R,ShortType),IntType);
end;
end;
MakeIndex := MakeNode(LeftBrack1, L, R, TP, 0);
end;
Function GetReference : ExprPtr;
var
Left,
Right : ExprPtr;
Leave : Boolean;
TP : TypePtr;
ID : IDPtr;
begin
ID := FindWithField(SymText);
if ID = Nil then
ID := FindID(SymText);
NextSymbol;
if ID = Nil then begin
ID := EnterStandard(SymText, global, BadType, st_none, 1);
{ ReadBadArgs(ID); }
GetReference := BuildError("Unknown ID");
end;
case ID^.Object of
obtype : begin
NeedLeftParent;
Left := MakeNode(type1, GetReference, Nil, ID^.VType, 0);
NeedRightParent;
end;
global,
local,
refarg,
typed_const,
valarg,
proc,
func : Left := MakeNode(Var1, Nil, Nil, ID^.VType, Integer(ID));
field : Left := MakeNode(Field1, ExprPtr(LastWith), Nil, ID^.VType, Integer(ID));
else
GetReference := BuildError("Expecting an identifier");
end;
Leave := False;
repeat
case CurrSym of { handle ., [, and '^' here }
period1 : begin
NextSymbol;
if Left^.EType^.Object = ob_record then begin
if CurrSym = ident1 then begin
ID := FindField(SymText, Left^.EType);
if ID <> Nil then
Left := MakeFieldRef(Left, ID^.Offset, ID^.VType)
else
Left := BuildError("Unknown Field");
NextSymbol;
end else
Left := BuildError("Expecting an identifier");
end else
Left := BuildError("Not a Record Type");
end;
carat1 : begin
NextSymbol;
if (Left^.EType^.Object <> ob_pointer) and
(Left^.EType^.Object <> ob_file) then
Left := BuildError("Expecting a pointer or file for ^")
else
Left := MakeIndirection(Left)
end;
leftbrack1 :
begin
NextSymbol;
repeat
if Left^.EType^.Object = ob_array then begin
Right := ExpressionTree;
if not TypeCheck(Right^.EType, Left^.EType^.Ref) then
MisMatch;
if Right^.Kind = Const1 then begin
if RangeCheck then begin
if (Right^.Value > Left^.EType^.Upper) or
(Right^.Value < Left^.EType^.Lower) then
Error("Index out of range");
end;
Left := MakeFieldRef(Left,
(Right^.Value - Left^.EType^.Lower) *
Left^.EType^.SubType^.Size,
Left^.EType^.SubType)
end else
Left := MakeIndex(Left,Right,Left^.EType^.SubType);
end else if Left^.EType = StringType then begin
Right := ExpressionTree;
if TypeCheck(Right^.EType, IntType) then
Left := MakeIndex(Left,Right,CharType)
else
Left := BuildError("Expecting an integer index");
end else
Left := BuildError("Not an Array Type");
until not Match(Comma1);
if not Match(RightBrack1) then
Error("Expecting ]");
end;
else
Leave := True;
end;
until Leave;
GetReference := Left;
end;
{ Create a factor tree. This level handles the seperators, which in
version 1.2 are now considered operators. }
Function Factor : ExprPtr;
var
Left,
Right : ExprPtr;
Leave : Boolean;
TP : TypePtr;
ID : IDPtr;
begin
Left := Primary;
Leave := False;
repeat
case CurrSym of { handle ., [, and '^' here }
period1 : begin
NextSymbol;
if Left^.EType^.Object = ob_record then begin
if CurrSym = ident1 then begin
ID := FindField(SymText, Left^.EType);
if ID <> Nil then
Left := MakeFieldRef(Left, ID^.Offset, ID^.VType)
else
Left := BuildError("Unknown Field");
NextSymbol;
end else
Left := BuildError("Expecting an identifier");
end else
Left := BuildError("Not a Record Type");
end;
carat1 : begin
NextSymbol;
if (Left^.EType^.Object <> ob_pointer) and
(Left^.EType^.Object <> ob_file) then
Left := BuildError("Expecting a pointer or file type")
else
Left := MakeIndirection(Left)
end;
leftbrack1 :
begin
NextSymbol;
repeat
if Left^.EType^.Object = ob_array then begin
Right := ExpressionTree;
if not TypeCheck(Right^.EType, Left^.EType^.Ref) then
MisMatch;
if Right^.Kind = Const1 then
Left := MakeFieldRef(Left,
(Right^.Value - Left^.EType^.Lower) *
Left^.EType^.SubType^.Size,
Left^.EType^.SubType)
else
Left := MakeIndex(Left,Right,Left^.EType^.SubType);
end else if Left^.EType = StringType then begin
Right := ExpressionTree;
if TypeCheck(Right^.EType, IntType) then
Left := MakeIndex(Left,Right,CharType)
else
Left := BuildError("Expecting an integer index");
end else
Left := BuildError("Not an Array Type");
until not Match(Comma1);
if not Match(RightBrack1) then
Error("Expecting ]");
end;
else
Leave := True;
end;
until Leave;
Factor := Left;
end;
{ Create a term tree. This routine handles multiplication, division,
and, shl, shr, and mod }
Function Term : ExprPtr;
var
Left,
Right : ExprPtr;
Leave : Boolean;
Op : Symbols;
begin
Left := Factor;
Leave := False;
repeat
case CurrSym of
asterisk1:
begin
CheckNumeric(Left);
NextSymbol;
Right := Factor;
CheckNumeric(Right);
CheckType(Left,Right);
Left := PromoteTypeA(Left, ShortType); { at least }
Left := PromoteTypeA(Left, Right^.EType);
Right := PromoteTypeA(Right, Left^.EType);
if Left^.EType^.Size < 4 then
Left := MakeCommutativeBinary(asterisk1, Left, Right, IntType)
else
Left := MakeBinary(asterisk1, Left, Right, Left^.EType);
end;
realdiv1 :
begin
CheckNumeric(Left);
NextSymbol;
Right := Factor;
CheckNumeric(Right);
CheckType(Left,Right);
Left := PromoteTypeA(Left, RealType);
Right := PromoteTypeA(Right, Left^.EType);
Left := MakeBinary(realdiv1, Right, Left, RealType);
end;
div1,
mod1: begin
Op := CurrSym;
CheckNumeric(Left);
NextSymbol;
Right := Factor;
CheckNumeric(Right);
CheckType(Left,Right);
Left := AutoInt(Left);
Right := AutoInt(Right);
Left := PromoteTypeA(Left, IntType);
Right := PromoteTypeA(Right, ShortType);
Left := MakeBinary(Op, Right, Left, Right^.EType);
end;
and1,
shl1,
shr1: begin
Op := CurrSym;
if Left^.EType = RealType then
Left := AutoInt(Left)
else
CheckOrdinal(Left);
NextSymbol;
Right := Factor;
if Right^.EType = RealType then
Right := AutoInt(Right)
else
CheckOrdinal(Right);
CheckType(Left,Right);
if NumberType(Left^.EType) then begin
Left := PromoteTypeA(Left, Right^.EType);
Right := PromoteTypeA(Right, Left^.EType);
if Op <> and1 then
Left := PromoteTypeA(Left, IntType);
end;
if (Op = And1) and
((Left^.EType <> BoolType) or (not ShortCircuit)) then
Left := MakeCommutativeBinary(Op, Left, Right, Left^.EType)
else
Left := MakeBinary(Op, Left, Right, Left^.EType);
end;
else
Leave := True;
end;
until Leave;
Term := Left;
end;
{ Create simple expression tree. This routine handles +, -, or, and xor }
Function Simple : ExprPtr;
var
Left,
Right : ExprPtr;
Leave : Boolean;
Op : Symbols;
begin
Left := Term;
Leave := False;
repeat
case CurrSym of
plus1,
minus1 : begin
Op := CurrSym;
CheckNumeric(Left);
NextSymbol;
Right := Term;
CheckNumeric(Right);
CheckType(Left,Right);
Left := PromoteTypeA(Left, Right^.EType);
Right := PromoteTypeA(Right, Left^.EType);
if Op = plus1 then
Left := MakeCommutativeBinary(Op, Left, Right, Left^.EType)
else
Left := MakeBinary(Op, Right, Left, Left^.EType);
end;
or1,
xor1: begin
Op := CurrSym;
if Left^.EType = RealType then
Left := AutoInt(Left)
else
CheckOrdinal(Left);
NextSymbol;
Right := Term;
if Right^.EType = RealType then
Right := AutoInt(Right)
else
CheckOrdinal(Right);
CheckType(Left,Right);
if NumberType(Left^.EType) then begin
Left := PromoteTypeA(Left, Right^.EType);
Right := PromoteTypeA(Right, Left^.EType);
end;
if (not ShortCircuit) or (Op <> or1) or
(Left^.EType <> BoolType) then
Left := MakeCommutativeBinary(Op, Left, Right, Left^.EType)
else
Left := MakeBinary(Op, Left, Right, Left^.EType);
end;
else
Leave := True;
end;
until Leave;
Simple := Left;
end;
{ Create an expression tree. This routine calls the others, and
handles comparison operators, which have the lowest precedence. }
Function ExpressionTree : ExprPtr;
var
Left,
Right : ExprPtr;
Leave : Boolean;
Op : Symbols;
begin
Left := Simple;
Leave := False;
repeat
case CurrSym of
less1,
greater1,
notless1,
notgreater1 : begin
Op := CurrSym;
if Left^.EType <> RealType then
CheckOrdinal(Left);
NextSymbol;
Right := Simple;
if Right^.EType <> RealType then
CheckOrdinal(Right);
CheckType(Left, Right);
if NumberType(Left^.EType) then begin
if Left^.EType = ByteType then
Left := PromoteTypeA(Left, ShortType);
Left := PromoteTypeA(Left, Right^.EType);
Right := PromoteTypeA(Right, Left^.EType);
end;
Left := MakeBinary(Op, Left, Right, BoolType);
end;
equal1,
notequal1 : begin
Op := CurrSym;
NextSymbol;
Right := Simple;
CheckType(Left, Right);
if NumberType(Left^.EType) then begin
Left := PromoteTypeA(Left, Right^.EType);
Right := PromoteTypeA(Right, Left^.EType);
end;
Left := MakeCommutativeBinary(Op, Left, Right, BoolType);
end;
else
Leave := True;
end;
until Leave;
ExpressionTree := Left;
end;